home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmplabel.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  12KB  |  264 lines
  1. ;;; CMPLABEL  Exit manager.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (defvar *last-label* 0)
  10. (defvar *exit*)
  11. (defvar *unwind-exit*)
  12.  
  13. ;;; *last-label* holds the label# of the last used label.
  14. ;;; *exit* holds an 'exit', which is
  15. ;;;    ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM,
  16. ;;;    RETURN-CHARACTER, RETURN-LONG-FLOAT, RETURN-SHORT-FLOAT, or
  17. ;;;    RETURN-OBJECT).
  18. ;;; *unwind-exit* holds a list consisting of:
  19. ;;;    ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME,
  20. ;;;    JUMP, BDS-BIND (each pushed for a single special binding), and
  21. ;;;    cvar (which holds the bind stack pointer used to unbind).
  22.  
  23. (defmacro next-label () `(cons (incf *last-label*) nil))
  24.  
  25. (defmacro next-label* () `(cons (incf *last-label*) t))
  26.  
  27. (defmacro wt-label (label)
  28.   `(when (cdr ,label) (wt-nl1 "T" (car ,label) ":;")))
  29.  
  30. (defmacro wt-go (label)
  31.   `(progn (rplacd ,label t) (wt "goto T" (car ,label) ";")))
  32.  
  33. (defun unwind-bds (bds-cvar bds-bind)
  34.        (when bds-cvar (wt-nl "bds_unwind(V" bds-cvar ");"))
  35.        (dotimes* (n bds-bind) (wt-nl "bds_unwind1;")))
  36.  
  37. (defun unwind-exit (loc &optional (jump-p nil)
  38.                         &aux (*vs* *vs*) (bds-cvar nil) (bds-bind 0))
  39.   (declare (fixnum bds-bind))
  40.   (when (and (eq loc 'fun-val)
  41.              (not (eq *value-to-go* 'return))
  42.              (not (eq *value-to-go* 'top)))
  43.         (wt-nl) (reset-top))
  44.   (cond ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-true))
  45.          (set-jump-true loc (cadr *value-to-go*))
  46.          (when (eq loc t) (return-from unwind-exit)))
  47.         ((and (consp *value-to-go*) (eq (car *value-to-go*) 'jump-false))
  48.          (set-jump-false loc (cadr *value-to-go*))
  49.          (when (null loc) (return-from unwind-exit))))
  50.   (dolist* (ue *unwind-exit* (baboon))
  51.     (cond
  52.        ((consp ue)
  53.         (cond ((eq ue *exit*)
  54.                (cond ((and (consp *value-to-go*)
  55.                            (or (eq (car *value-to-go*) 'jump-true)
  56.                                (eq (car *value-to-go*) 'jump-false)))
  57.                       (unwind-bds bds-cvar bds-bind))
  58.                      (t
  59.                       (if (or bds-cvar (plusp bds-bind))
  60.                           ;;; Save the value if LOC may possibly refer
  61.                           ;;; to special binding.
  62.                           (if (and (consp loc)
  63.                                    (or (and (eq (car loc) 'var)
  64.                                             (member (var-kind (cadr loc))
  65.                                                     '(SPECIAL GLOBAL)))
  66.                                        (member (car loc)
  67.                                                '(SIMPLE-CALL INLINE
  68.                                                  INLINE-COND INLINE-FIXNUM
  69.                                                  INLINE-CHARACTER
  70.                                                  INLINE-LONG-FLOAT
  71.                                                  INLINE-SHORT-FLOAT))))
  72.                               (cond ((and (consp *value-to-go*)
  73.                                           (eq (car *value-to-go*) 'vs))
  74.                                      (set-loc loc)
  75.                                      (unwind-bds bds-cvar bds-bind))
  76.                                     (t (let ((temp (list 'vs (vs-push))))
  77.                                             (let ((*value-to-go* temp))
  78.                                                  (set-loc loc))
  79.                                             (unwind-bds bds-cvar bds-bind)
  80.                                             (set-loc temp))))
  81.                               (progn (unwind-bds bds-cvar bds-bind)
  82.                                      (set-loc loc)))
  83.                           (set-loc loc))))
  84.                (when jump-p (wt-nl) (wt-go *exit*))
  85.                (return))
  86.               (t (setq jump-p t))))
  87.        ((numberp ue) (setq bds-cvar ue bds-bind 0))
  88.        ((eq ue 'bds-bind) (incf bds-bind))
  89.        ((eq ue 'return)
  90.         (when (eq *exit* 'return)
  91.               ;;; *VALUE-TO-GO* must be either *RETURN* or *TRASH*.
  92.               (set-loc loc)
  93.               (unwind-bds bds-cvar bds-bind)
  94.               (wt-nl "return;")
  95.               (return))
  96.         ;;; Never reached
  97.         )
  98.        ((eq ue 'frame)
  99.         (when (and (consp loc)
  100.                    (member (car loc)
  101.                            '(SIMPLE-CALL INLINE INLINE-COND INLINE-FIXNUM
  102.                              INLINE-CHARACTER INLINE-LONG-FLOAT
  103.                              INLINE-SHORT-FLOAT)))
  104.               (cond ((and (consp *value-to-go*)
  105.                           (eq (car *value-to-go*) 'vs))
  106.                      (set-loc loc)
  107.                      (setq loc *value-to-go*))
  108.                     (t (let ((*value-to-go* (list 'vs (vs-push))))
  109.                             (set-loc loc)
  110.                             (setq loc *value-to-go*)))))
  111.         (wt-nl "frs_pop();"))
  112.        ((eq ue 'tail-recursion-mark))
  113.        ((eq ue 'jump) (setq jump-p t))
  114.        ((eq ue 'return-fixnum)
  115.         (when (eq *exit* 'return-fixnum)
  116.               ;;; *VALUE-TO-GO* must be RETURN-FIXNUM
  117.               (cond ((or bds-cvar (plusp bds-bind))
  118.                      (cond ((fixnum-loc-p loc)
  119.                             (let ((cvar (next-cvar)))
  120.                                  (wt-nl "{int V" cvar "= ")
  121.                                  (wt-fixnum-loc loc) (wt ";")
  122.                                  (unwind-bds bds-cvar bds-bind)
  123.                                  (wt-nl "VMR" *reservation-cmacro*
  124.                                         "(V" cvar ")}")))
  125.                            (t (let ((vs (vs-push)))
  126.                                    (wt-nl) (wt-vs vs) (wt "= " loc ";")
  127.                                    (unwind-bds bds-cvar bds-bind)
  128.                                    (wt-nl "VMR" *reservation-cmacro*
  129.                                           "(fix(") (wt-vs vs) (wt "))")
  130.                                    ))))
  131.                     (t (wt-nl "VMR" *reservation-cmacro* "(")
  132.                               (wt-fixnum-loc loc) (wt ")")))
  133.               (return)))
  134.        ((eq ue 'return-character)
  135.         (when (eq *exit* 'return-character)
  136.               ;;; *VALUE-TO-GO* must be RETURN-CHARACTER
  137.               (cond ((or bds-cvar (plusp bds-bind))
  138.                      (cond ((character-loc-p loc)
  139.                             (let ((cvar (next-cvar)))
  140.                                  (wt-nl "{unsigned char V" cvar "= ")
  141.                                  (wt-character-loc loc) (wt ";")
  142.                                  (unwind-bds bds-cvar bds-bind)
  143.                                  (wt-nl "VMR" *reservation-cmacro*
  144.                                         "(V" cvar ")}")))
  145.                            (t (let ((vs (vs-push)))
  146.                                    (wt-nl) (wt-vs vs) (wt "= " loc ";")
  147.                                    (unwind-bds bds-cvar bds-bind)
  148.                                    (wt-nl "VMR" *reservation-cmacro*
  149.                                           "(char-code(") (wt-vs vs) (wt "))")
  150.                                    ))))
  151.                     (t (wt-nl "VMR" *reservation-cmacro* "(")
  152.                        (wt-character-loc loc) (wt ")")))
  153.               (return)))
  154.        ((eq ue 'return-long-float)
  155.         (when (eq *exit* 'return-long-float)
  156.               ;;; *VALUE-TO-GO* must be RETURN-LONG-FLOAT
  157.               (cond ((or bds-cvar (plusp bds-bind))
  158.                      (cond ((long-float-loc-p loc)
  159.                             (let ((cvar (next-cvar)))
  160.                                  (wt-nl "{int V" cvar "= ")
  161.                                  (wt-long-float-loc loc) (wt ";")
  162.                                  (unwind-bds bds-cvar bds-bind)
  163.                                  (wt-nl "VMR" *reservation-cmacro*
  164.                                         "(V" cvar ")}")))
  165.                            (t (let ((vs (vs-push)))
  166.                                    (wt-nl) (wt-vs vs) (wt "= " loc ";")
  167.                                    (unwind-bds bds-cvar bds-bind)
  168.                                    (wt-nl "VMR" *reservation-cmacro*
  169.                                           "(fix(") (wt-vs vs) (wt "))")
  170.                                    ))))
  171.                     (t (wt-nl "VMR" *reservation-cmacro* "(")
  172.                        (wt-long-float-loc loc) (wt ")")))
  173.               (return)))
  174.        ((eq ue 'return-short-float)
  175.         (when (eq *exit* 'return-short-float)
  176.               ;;; *VALUE-TO-GO* must be RETURN-SHORT-FLOAT
  177.               (cond ((or bds-cvar (plusp bds-bind))
  178.                      (cond ((short-float-loc-p loc)
  179.                             (let ((cvar (next-cvar)))
  180.                                  (wt-nl "{int V" cvar "= ")
  181.                                  (wt-short-float-loc loc) (wt ";")
  182.                                  (unwind-bds bds-cvar bds-bind)
  183.                                  (wt-nl "VMR" *reservation-cmacro*
  184.                                         "(V" cvar ")}")))
  185.                            (t (let ((vs (vs-push)))
  186.                                    (wt-nl) (wt-vs vs) (wt "= " loc ";")
  187.                                    (unwind-bds bds-cvar bds-bind)
  188.                                    (wt-nl "VMR" *reservation-cmacro*
  189.                                           "(fix(") (wt-vs vs) (wt "))")
  190.                                    ))))
  191.                     (t (wt-nl "VMR" *reservation-cmacro* "(")
  192.                               (wt-short-float-loc loc) (wt ")")))
  193.               (return)))
  194.        ((eq ue 'return-object)
  195.         (when (eq *exit* 'return-object)
  196.               ;;; *VALUE-TO-GO* must be RETURN-OBJECT
  197.               (cond ((or bds-cvar (plusp bds-bind))
  198.                      (let ((vs (vs-push)))
  199.                           (wt-nl) (wt-vs vs) (wt "= " loc ";")
  200.                           (unwind-bds bds-cvar bds-bind)
  201.                           (wt-nl "VMR" *reservation-cmacro* "(")
  202.                                  (wt-vs vs) (wt ")")
  203.                           ))
  204.                     (t (wt-nl "VMR" *reservation-cmacro* "(" loc ")")))
  205.               (return)))
  206.        (t (baboon))
  207.        ;;; Never reached
  208.        ))
  209.   )
  210.  
  211. (defun unwind-no-exit (exit &aux (bds-cvar nil) (bds-bind 0))
  212.   (declare (fixnum bds-bind))
  213.   (dolist* (ue *unwind-exit* (baboon))
  214.     (cond
  215.        ((consp ue)
  216.         (when (eq ue exit)
  217.               (unwind-bds bds-cvar bds-bind)
  218.               (return)))
  219.        ((numberp ue) (setq bds-cvar ue bds-bind 0))
  220.        ((eq ue 'bds-bind) (incf bds-bind))
  221.        ((member ue '(return return-object return-fixnum return-character
  222.                             return-long-float return-short-float))
  223.         (cond ((eq exit ue) (unwind-bds bds-cvar bds-bind)
  224.                             (return))
  225.               (t (baboon)))
  226.         ;;; Never reached
  227.         )
  228.        ((eq ue 'frame) (wt-nl "frs_pop();"))
  229.        ((eq ue 'tail-recursion-mark)
  230.         (cond ((eq exit 'tail-recursion-mark) (unwind-bds bds-cvar bds-bind)
  231.                                               (return))
  232.               (t (baboon)))
  233.         ;;; Never reached
  234.         )
  235.        ((eq ue 'jump))
  236.        (t (baboon))
  237.        ;;; Never reached
  238.        ))
  239.   )
  240.  
  241. ;;; Tail-recursion optimization for a function F is possible only if
  242. ;;;    1. the value of *DO-TAIL-RECURSION* is non-nil (this is default),
  243. ;;;    2. F receives only required parameters, and
  244. ;;;    3. no required parameter of F is enclosed in a closure.
  245. ;;;
  246. ;;; A recursive call (F e1 ... en) may be replaced by a loop only if
  247. ;;;    1. F is not declared as NOTINLINE,
  248. ;;;    2. n is equal to the number of required parameters of F,
  249. ;;;    3. the form is a normal function call (i.e. the arguments are
  250. ;;;       pushed on the stack,
  251. ;;;    4. (F e1 ... en) is not surrounded by a form that causes dynamic
  252. ;;;       binding (such as LET, LET*, PROGV),
  253. ;;;    5. (F e1 ... en) is not surrounded by a form that that pushes a frame
  254. ;;;       onto the frame-stack (such as BLOCK and TAGBODY whose tags are
  255. ;;;       enclosed in a closure, and CATCH),
  256.  
  257. (defun tail-recursion-possible ()
  258.   (dolist* (ue *unwind-exit* (baboon))
  259.     (cond ((eq ue 'tail-recursion-mark) (return t))
  260.           ((or (numberp ue) (eq ue 'bds-bind) (eq ue 'frame))
  261.            (return nil))
  262.           ((or (consp ue) (eq ue 'jump)))
  263.           (t (baboon)))))
  264.